{-# LANGUAGE FlexibleInstances,OverlappingInstances,TypeSynonymInstances #-}

module Text.HJson (SourceSpan(..),Key(..),Json(..), Jsonable(..), fromString, toString, escapeJString) where

import Data.Char
import Data.List
import Data.Maybe
import Data.Ratio
import Safe
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
import Text.ParserCombinators.Parsec.Prim

data SourceSpan = SrcSpan { srcFrom :: SourcePos, srcTo :: SourcePos } deriving (Show, Eq) 

-- | Is used every time a type is just convertet into Json (and therefore not parsed from input string)
dummySpan :: SourceSpan
dummySpan = SrcSpan (newPos "not_parsed" (-1) (-1)) (newPos "not_parsed" (-1) (-1))


data Key = JKey SourceSpan String deriving (Eq, Show)

instance Ord Key where
  (JKey _ s1) <= (JKey _ s2) = s1 <= s2

data Json = JString SourceSpan String
          | JNumber SourceSpan Rational
          | JObject SourceSpan [(Key,Json)]
          | JBool   SourceSpan Bool
          | JNull   SourceSpan
          | JArray  SourceSpan [Json] 
          deriving (Eq, Show)

-- | Renders JSON to String
toString :: Json -> String
toString (JNumber _ r) | denominator r == 1 = show (numerator r)
	| otherwise = show (fromRational r :: Double)
toString (JString _ s) = "\"" ++ escapeJString s ++ "\""
toString (JObject _ l) = "{" ++ (intercalate ", " $ map (\((JKey _ k), v) -> toString (JString dummySpan k) ++ ": " ++ toString v) (l)) ++ "}" -- the use of dummySpan has no effect, its just requierd by the constructor
toString (JBool _ True) = "true"
toString (JBool _ False) = "false"
toString (JNull _) = "null"
toString (JArray _ vs) = "[" ++ (intercalate ", " $ map (toString) vs) ++ "]"

-- | Parses JSON string
fromString :: String -> Either String Json
fromString s = either (Left . show) (Right) $ parse valueP "user_input" s

-- | Escapes string for inclusion in JSON
escapeJString :: String -> String
escapeJString = concat . map (escapeJChar)

-- | Class of types that can be converted to or from JSON
class Jsonable a where
	toJson :: a -> Json
	fromJson :: Json -> Maybe a
	fromJson = const Nothing

-- Simple, but useful
instance Jsonable Json where
	toJson = id
	fromJson _ = Nothing
instance Jsonable Bool where
	toJson b = JBool dummySpan b
	fromJson (JBool _ b) = Just b
	fromJson _ = Nothing
instance Jsonable Integer where
 	toJson i = jsonifyIntegral i
 	fromJson (JNumber _ i) = Just $ round i
	fromJson _ = Nothing
instance Jsonable Int where
 	toJson = jsonifyIntegral
 	fromJson (JNumber _ i) = Just $ round i
	fromJson _ = Nothing
instance Jsonable Double where
	toJson = jsonifyRealFrac
	fromJson (JNumber _ i) = Just $ fromRational i
	fromJson _ = Nothing
instance Jsonable Float where
	toJson = jsonifyRealFrac
	fromJson (JNumber _ i) = Just $ fromRational i
	fromJson _ = Nothing
instance Jsonable String where
	toJson = JString dummySpan
	fromJson (JString _ s) = Just s
	fromJson _ = Nothing
instance (Jsonable a) => Jsonable ([(String,a)]) where
--	toJson = JObject . map (\(k,v) -> (k,(toJson v)))   -- auskommentiert, da ich mir nicht sicher bin wie ich die SrcSpan behandeln soll
	fromJson (JObject _ m) = Just $ map (\(JKey _ k,v) -> (k,fromJust $ fromJson v)) m
	fromJson _ = Nothing
instance (Jsonable a) => Jsonable [a] where
--	toJson = JArray . map toJson -- auskommentiert, da ich mir nicht sicher bin wie ich die SrcSpan behandeln soll
	fromJson (JArray _ as )= Just $ map (fromJust . fromJson) as

-- private functions

-- Here I manually did instances' job. You know who to blame for its incompleteness.
jsonifyRealFrac i = JNumber dummySpan (approxRational i 1e-666)
jsonifyIntegral i = JNumber dummySpan (fromIntegral i % 1)

escapeJChar '\n' = "\\n"
escapeJChar '\b' = "\\b"
escapeJChar '\f' = "\\f"
escapeJChar '\t' = "\\t"
escapeJChar '\r' = "\\r"
escapeJChar '\\' = "\\\\"
escapeJChar '"' = "\\\""
escapeJChar c = [c]

-- Parser

valueP = do
	spaces
	jsonV <- stringP <|> numberP <|> objectP <|> arrayP <|> boolP <|> nullP
	spaces
	return jsonV

objectP = do
        srcFrom <- getPosition
	char '{'
	spaces
	values <- keyValueP `sepBy` commaP
	spaces
	char '}'
	srcTo <- getPosition
	return (JObject (SrcSpan srcFrom srcTo) values)

commaP = do
	spaces
	char ','
	spaces

keyValueP = do
	spaces
        srcFrom <- getPosition
	JString dummySpan keyStringV <- stringP
        srcTo <- getPosition
	spaces
	char ':'
	spaces
	valueV <- valueP
	spaces
	return (JKey (SrcSpan srcFrom srcTo) keyStringV, valueV)

arrayP = do
        srcFrom <- getPosition
	char '['
	spaces
	values <- valueP `sepBy` commaP
	spaces
	char ']'
	srcTo <- getPosition
	return (JArray (SrcSpan srcFrom srcTo) values)

stringP = do
        srcFrom <- getPosition
	char '"'
	str <- manyTill stringElementP (char '"')
	srcTo <- getPosition
        return (JString (SrcSpan srcFrom srcTo) str)

stringElementP = do
	escapeSeqP <|> anyChar

escapeSeqP = do
	char '\\'
	(char '"') <|>
		(char '\\') <|>
		(char '/') <|>
		('\b' <$ char 'b') <|>
		('\f' <$ char 'f') <|>
		('\n' <$ char 'n') <|>
		('\r' <$ char 'r') <|>
		('\t' <$ char 't') <|>
		unicodeP

unicodeP = do
	digitsV <- count 4 hexDigit
	let numberV = read ("0x" ++ digitsV)
	return $ chr numberV

numberP = do
        srcFrom <- getPosition
	minusV <- optionMaybe (char '-')
	digitsV <- many1 digit
	maybeFractionalV <- optionMaybe (char '.' >> many digit)
	exponentV <- optionMaybe (do
		oneOf "eE"
		signV <- optionMaybe (char '+' <|> char '-')
		eDigitsV <- many1 digit
		let readDigits = read eDigitsV :: Integer
		return $ case signV of
			Just '-' -> ('-', readDigits)
			otherwise -> ('+', readDigits))
	let fractionalV = fromMaybe "" maybeFractionalV
	let upV = read (digitsV ++ fractionalV) :: Integer
	let downV = 10 ^ genericLength fractionalV
	srcTo <- getPosition
	return $ case exponentV of
		Nothing -> JNumber (SrcSpan srcFrom srcTo) (upV % downV)
		Just ('-', powr) -> JNumber (SrcSpan srcFrom srcTo) (upV % (downV * 10 ^ powr))
		Just (_, powr) -> JNumber (SrcSpan srcFrom srcTo) ((upV * 10 ^ powr) % downV)

--boolP = (JBool True <$ string "true") <|> (JBool False <$ string "false")

boolTrueP = do
            srcFrom <- getPosition
            string "true"
            srcTo <- getPosition
            return (JBool (SrcSpan srcFrom srcTo) True)

boolFalseP = do
             srcFrom <- getPosition
             string "false"
             srcTo <- getPosition
             return (JBool (SrcSpan srcFrom srcTo) False)

boolP = do
        boolValue <- boolTrueP <|> boolFalseP
        return boolValue

--nullP = JNull <$ string "null"

nullP = do
        srcFrom <- getPosition
        string "null"
        srcTo <- getPosition
        return $ JNull (SrcSpan srcFrom srcTo)

x <$ m = m >> return x
